home *** CD-ROM | disk | FTP | other *** search
/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / ｵﾝﾗｲﾝｿﾌﾄ定点観測 / ﾕｰﾃｨﾘﾃｨ / Mops 3.2.sea / Mops 3.2 / Mops ƒ / zArgs < prev    next >
Text File  |  1998-06-20  |  10KB  |  404 lines
  1. ¥ zArgs - support for named parms and local variables
  2.  
  3.  
  4. (*    This file is the PPC equivalent of the 68k "Args" file.  It's a
  5.     "z" file - it's not target compiled, but is loaded on the PPC itself.
  6.     Args has EVALUATE - the PPC EVALUATE has already been target compiled
  7.     in pArgs since we needed it earlier.  Here we include everything else.
  8. *)
  9.  
  10.    11    constant    MAXPL        ¥ We can only spare 11 regs on PPC,
  11.                                    ¥  or 10 if we use I (r21).
  12. false    value        LOCFLG        ¥ true = looking for local var tokens
  13.     0    value        LOC_ADDR
  14.  
  15.  
  16. create    PARMLIST    maxPL cells 8 +  reserve
  17. create    FPARMLIST    maxPL cells 8 +  reserve
  18.  
  19.  
  20.     0    value    SVHASH
  21. false    value    FLOAT?
  22.     0    value    PLentry_addr
  23.  
  24.  
  25. : INITLOCS        ¥ Initializes flags etc.
  26.     0 -> #PL  0 -> #P  0 -> #FPL  0 -> #FP
  27.     0 -> FltFlg  false -> locFlg  ;
  28.  
  29.  
  30. : FINDINPARMLIST        ¥ ( addr -- loc# T  OR  -- F )
  31.             ¥ loc# counts from right to left in the local/parm list.
  32.     dup 1+ c@   & %  =  -> float?
  33.     hash -> svHash  false
  34.  
  35.     float?
  36.     IF        #FPL  0EXIT  fparmlist  #FPL
  37.     ELSE    #PL   0EXIT  parmlist   #PL
  38.     THEN
  39.  
  40.     4*  bounds
  41.     DO    svHash  i @ =
  42.         IF  ( found )
  43.             drop  
  44.             float?
  45.             IF        #FPL  i fparmlist -
  46.             ELSE    #PL   i parmlist  -
  47.             THEN
  48.             4/ -  1-  true  LEAVE
  49.         THEN
  50.     4 +LOOP  ;
  51.  
  52.  
  53. : ADDTOPARMLIST        ¥ ( addr -- )  Adds an element to parmList.
  54.                     ¥  addr points to a counted string.
  55.  
  56.     findinParmList  ?error 95        ¥ Name not unique
  57.     #PL  maxPL  >  ?error 110        ¥ too many parms/locals
  58.     svHash
  59.     float?
  60.     IF        #FPL 1 ++> #FPL 4*  fParmlist +  !
  61.             locFlg NIF  1 ++> #FP  THEN
  62.     ELSE    #PL  1 ++> #PL  4*  parmlist  +  !
  63.             locFlg NIF  1 ++> #P  THEN
  64.     THEN
  65. ;
  66.  
  67.  
  68. : FIRSTCHR  ( -- c )
  69.     inline{ CDP 1+ c@}  ;
  70.  
  71. 0 value testxxx
  72.  
  73. :f {
  74.     local? IF            ¥ local? already non-zero - this ought to mean we're
  75.                         ¥  in a local section
  76.         local? 0< ?error 92  -1 -> local?
  77.     THEN
  78.     initLocs
  79.  
  80.     BEGIN                    ¥ Loop to add parms/locals to parmlist
  81.         Mword drop
  82.         firstChr  & -  <>            ¥ look for --
  83.     WHILE
  84.         firstChr dup  & ¥  =  swap  & /  =  or
  85.                 ¥ Note: we allow / as an alternative to ¥ in this context,
  86.                 ¥  since it's an easy mistake to make, and / isn't a
  87.                 ¥  sensible parm name since it already has a meaning.
  88.  
  89.         IF        true -> locFlg
  90.         ELSE    firstChr  & } =  ?error 111
  91.                 CDP  addToParmList
  92.         THEN
  93.     REPEAT
  94.  
  95.     local? NIF                ¥ In local sections, we do this at :LOC
  96.         CDP  -> PLentry_addr
  97.             ¥  If we have temp objects, we'll have to backup the DP and
  98.             ¥  recompile the entry sequence, since there'll be an extra local
  99.             ¥  (the frame pointer)
  100.         PLentry
  101.     THEN
  102.  
  103.     BEGIN                    ¥ Loop gobble chars until }
  104.         Mword drop
  105.         firstChr  & }  =            ¥ look for }
  106.     UNTIL
  107. ;f
  108.  
  109.  
  110. ¥ FIND will call the forward-defined initFind first, to attempt to find
  111. ¥  a name.  At this stage in building the system we need to look for
  112. ¥  named parms & locals, so we define a word pFind which looks for them,
  113. ¥  and resolve initFind to pFind.  Later we'll re-resolve initFind to look
  114. ¥  for selectors, etc. as well as calling pFind.
  115.  
  116. ¥  If pFind finds the name is a parm/local, it returns true and the
  117. ¥  cfa of LocParm, which is a dummy word whose handler compiles
  118. ¥  a local reference.
  119.  
  120. : PFIND        ¥ ( str-addr -- cfa T  |  -- str-addr F )
  121.     state        NIF  false  EXIT  THEN
  122.     #PL #FPL or    NIF  false  EXIT  THEN
  123.  
  124.     dup  findInParmList  NIF  false  EXIT  THEN
  125.     
  126. ¥ found it!
  127.  
  128.     -> loc#  drop
  129.     float? IF  <'> FlocParm  ELSE  <'> locParm  THEN
  130.     true
  131. ;
  132.  
  133. :f initFind  pFind  ;f
  134.  
  135.  
  136. : ,EXEC        ¥ ( cfa n -- )
  137.     state
  138.     IF  (compN)  ELSE  exN  THEN  ;
  139.  
  140. ¥ Here are the different types that we can put prefixes on or send
  141. ¥ messages to:
  142.  
  143. enum{    notfnd  locTyp  flocTyp
  144.         tmpObjTyp  objTyp  ivarTyp  classTyp  superTyp
  145.         valTyp  fvalTyp  vecTyp  dynVecTyp  objptrTyp
  146.         regTyp  lbTyp  lbSelfTyp  bktTyp  wordTyp  }
  147.  
  148.  
  149. (*    notFnd    - not previously defined
  150.     locTyp    - a local or named parm
  151.     tmpObjTyp    - a temporary (local) object
  152.     objTyp    - an object
  153.     ivarTyp    - an ivar
  154.     classTyp    - a class
  155.     superTyp    - a named superclass specified by  msg: super> someClass
  156.     valTyp    - a value
  157.     FvalTyp    - a floating point value
  158.     vecTyp    - a vector
  159.     dynVecTyp    - a dynamic vector
  160.     regTyp    - a 680x0 register
  161.     lbTyp        - ** or [] meaning late bind
  162.     lbSelfTyp    - [self] meaning late bind to self
  163.     BktTyp    - [ - Neon-compatible late bind
  164.     wordTyp    - a word
  165. *)
  166.  
  167. : HDLR    ( xt - handler_code )
  168.     inline{ 2- w@}  ;
  169.  
  170. ¥ PRFTOKEN returns the type of a token for a prefix op.
  171.  
  172. : PRFTOKEN    ¥ ( -- cfa type )
  173.  
  174.     '  dup  <'> locParm  =  IF  locTyp    EXIT  THEN
  175.        dup  <'> FlocParm =  IF  FlocTyp    EXIT  THEN
  176.     dup  hdlr
  177.     CASE
  178.         $ BC03        OF    valTyp        ENDOF
  179.         $ BC27        OF    FvalTyp        ENDOF
  180.         $ BC05        OF    vecTyp        ENDOF
  181.         $ BC3D        OF    vecTyp        ENDOF    ¥ sVect
  182.         $ BC3B        OF    dynVecTyp    ENDOF
  183.         $ BD0A        OF    regTyp        ENDOF
  184.         $ BC1F        OF    objPtrTyp    ENDOF
  185.         114 die
  186.     ENDCASE  ;
  187.  
  188. forward    ToObjPtr        ¥ Stores to an objPtr.  Defined in file Class.
  189.  
  190. : ->
  191.     prfToken                ¥ All types are legal
  192.     objPtrTyp =  IF  toObjPtr  EXIT  THEN
  193.     $ 60  ( opcode for Store )  ,exec
  194. ;        immediate            ¥ NOTE: opcode for store hard coded here!!!
  195.  
  196.  
  197. : CvrtFcode    ¥ ( code -- code' )
  198.     CASE
  199.         $ 21  OF  $ 41  ENDOF        ¥ +
  200.         $ 22  OF  $ 48  ENDOF        ¥ -
  201.         $ 28  OF  $ 55  ENDOF        ¥ Neg
  202.         ?error 114
  203.     ENDCASE  ;
  204.  
  205. : (+->)        ¥ ( code -- cfa code' )
  206.     PrfToken ( code cfa type )  rot swap ( cfa code type )
  207.     
  208.     CASE
  209.         locTyp        OF                ENDOF
  210.         FlocTyp        OF  cvrtFcode    ENDOF
  211.         valTyp        OF                ENDOF
  212.         FvalTyp        OF  cvrtFcode    ENDOF
  213.         regTyp        OF                ENDOF
  214.         ?error 114
  215.     ENDCASE  ;
  216.  
  217. : (FOP)
  218.     PrfToken  rot swap
  219.     CASE
  220.         locTyp        OF  ENDOF
  221.         FlocTyp        OF  ENDOF
  222.         FvalTyp        OF  ENDOF
  223.         ?error 114
  224.     ENDCASE  ;
  225.  
  226.  
  227. ¥ Note: the following opcodes have to agree with the definitions in
  228. ¥ OD.asm.  I could have defined them as constants but this would have
  229. ¥ used up dictionary space for no great benefit.
  230.  
  231. : ++>    $ 21  (+->)  ,exec  ;        immediate
  232. : +>    postpone  ++>       ;        immediate        ¥ A synonym.
  233. : -->    $ 22  (+->)  ,exec  ;        immediate
  234. : AND>    $ 23  (+->)  ,exec  ;        immediate
  235. : OR>    $ 24  (+->)  ,exec  ;        immediate
  236. : XOR>    $ 25  (+->)  ,exec  ;        immediate
  237. : NEG>    $ 28  (+->)  ,exec  ;        immediate
  238. : NOT>    $ 29  (+->)  ,exec  ;        immediate
  239. : *>    $ 42  (fop)  ,exec  ;        immediate
  240. : />    $ 49  (fop)  ,exec  ;        immediate
  241. : ABS>    $ 54  (fop)  ,exec  ;        immediate
  242.  
  243.  
  244. ¥ ' Pfind  -> Ufind
  245.  
  246. ¥         =========== Local sections ===========
  247.  
  248.  
  249. forward        INITTEMPS
  250.  
  251. : ?LOC    local? 0=  ?error 91  ;            ¥ "We're not in a local section"
  252.  
  253.  
  254. : LOCAL
  255.     local?  ?error 93  1 -> local?        ¥ We change it to the normal -1
  256.                                         ¥ as soon as "{" is read.
  257.     CDP -> CD_gpr_loc
  258.     forward                                ¥ LOCAL is just like FORWARD
  259.     CDP 4- -> loc_addr
  260. ;
  261.  
  262.  
  263. : :LOC
  264.     local? 1 = IF  msg# 96  THEN    ¥ warning  - no locals defined
  265.     ?loc
  266.     ' drop                            ¥ gobble word name
  267.  
  268.     CDP -> const_data_start            ¥ the following is like :f (see qpCond)
  269.     $ BE020000  code,                ¥ marks this as the :loc position
  270.                                     ¥  (just for disassembly)
  271.  
  272.     false -> method?
  273.     false -> local?                    ¥ so entry sequence gets compiled
  274.     true ppc_entry                    ¥ handle ppc proc entry.  We're handling
  275.                                     ¥  local sections by calling FORWARD,
  276.                                     ¥  so we need to tell ppc_entry this
  277.                                     ¥  is a forward defn so the parms get
  278.                                     ¥  handled properly.
  279.     fwd_gpr_rtn_cnt  -> gpr_rtn_cnt
  280.     fwd_fpr_rtn_cnt  -> fpr_rtn_cnt
  281.     drop 304                        ¥ security marker for :loc
  282.     curr-def
  283.       loc_addr -> curr-def
  284.       PLentry
  285.     -> curr-def
  286.     tempObj_frameSize IF  initTemps  THEN
  287. ;        immediate
  288.  
  289. : ;LOC
  290.     304 ?defn
  291.     false -> leaf?            ¥ let's just reduce the bug possibilities!
  292.     loc_addr 2-  (;)
  293.     loc_addr curr-def  resolve_unconditional_branch
  294.                             ¥ finally resolve the forward branch
  295.                             ¥   from LOCAL
  296. ;            immediate
  297.  
  298.  
  299. ¥            ============================================
  300.  
  301. ¥ EVALUATE was already loaded in pArgs, along with the value compinline?.
  302.  
  303. : (COMPINL)        ¥ ( xt -- )
  304.  
  305.     true -> compinline?
  306.     2+ count  evaluate
  307.     false -> compinline?  ;
  308.  
  309. ' (compinl) -> compinline
  310.  
  311.  
  312. : [IF]  { flag ¥ addr len level done? -- }
  313.  
  314.     flag  ?EXIT
  315.     false -> done?  1 -> level
  316.  
  317.     BEGIN
  318.         Mword count  -> len  -> addr
  319.                 addr len  " [THEN]" s=  IF  1 --> level
  320.         ELSE    addr len  " [ELSE]" s=    IF  level 1 =
  321.                                             IF  true -> done?  THEN
  322.         ELSE    addr len  " [IF]"   s=  IF  1 ++> level
  323.         THEN THEN THEN
  324.  
  325.         level  NIF  true -> done?  THEN
  326.         done?
  327.     UNTIL
  328. ;                immediate
  329.  
  330.  
  331. : [ELSE]  { ¥ addr len level done? -- }
  332.     false -> done?  1 -> level
  333.     BEGIN
  334.         Mword count  -> len  -> addr
  335.                 addr len    " [THEN]" s=  IF  1 --> level
  336.         ELSE    addr len    " [IF]"   s=  IF  1 ++> level
  337.         THEN THEN
  338.  
  339.         level  NIF  true -> done?  THEN
  340.         done?
  341.     UNTIL
  342. ;                immediate
  343.  
  344.  
  345. : [THEN]  ;        immediate
  346.  
  347.  
  348.  
  349. (*    INSTEAD ( c-old c-new -- )  may be used just after a SCON is defined.
  350.     Within the SCON, it replaces any occurrences of c-old with c-new.  This 
  351.     operation is useful for creating SCONs containing special characters
  352.     such as tab.
  353.     This logically should come after SCON in zBase, but it needs locals
  354.     so we'll put it here.
  355. *)
  356.  
  357. : INSTEAD  { c-old c-new -- }
  358.     latest name> ex-gen  bounds        ¥ SCONs use DOES> so require EX-GEN
  359.     DO   i c@ c-old = IF  c-new i c!  THEN
  360.     LOOP  ;
  361.  
  362.  
  363. ¥                    =============================
  364. ¥                            ASSERTIONS
  365. ¥                    =============================
  366.  
  367. (*    Assertions allow you, during development, to ensure that
  368.     things are the way they're supposed to be at key places.
  369.     
  370.     Usage:
  371.     ASSERT{ <something that evaluates to a flag> }
  372.     
  373.     If ASSERTIONS? is true, this will give error 216 ("assertion failed")
  374.     if the evaluated flag is false.  If ASSERTIONS? is false, nothing
  375.     will happen - the code between ASSERT{ and } isn't executed.
  376.  
  377.     ASSERTIONS? can be defined and redefined however and whenever you
  378.     like, as long as it returns a flag - ASSERT{ tests it via EVALUATE,
  379.     so the latest definition will always be the one that gets looked at.
  380.     If you have ASSERTIONS? defined as a constant with value false, no 
  381.     code will even be compiled for the assertion test - you can use this
  382.     for code that you know works.
  383. *)
  384.     
  385. false    constant    assertions?        ¥ redefine however and whenever necessary
  386.  
  387. : }ASSERT
  388.     134 ?pairs
  389.     ['] } >body !
  390.  
  391.     " NIF 216 die THEN THEN"  evaluate        ¥ assertion failed!
  392. ;        immediate
  393.  
  394.  
  395. : ASSERT{
  396.     ?comp
  397.     " assertions? if" evaluate
  398.     
  399.     ['] } >body @                ¥ save old action for "}"
  400.     ['] }assert  -> }            ¥ "}" will now be same as }assert
  401.     134
  402. ;        immediate
  403.  
  404.